home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / Float source / fArgs < prev    next >
Encoding:
Text File  |  1995-11-11  |  6.0 KB  |  164 lines  |  [TEXT/YERK]
  1. \ support for floating point named input parms
  2. \  9/22/85  cbd Version 1.0
  3. \ 12/03/87    rfl added ;m
  4. \  5/03/94    rfl    added mexit
  5. \  9/05/95    rfl    mexit moved to args
  6. \ 11/11/95    rfl    exit now works with methods...redefined ;m
  7.  
  8. \ fetch the 0th floating point arg  
  9. :CODE @fp0
  10.         move.l  YERK[(fltNew)],d7  
  11.         jsr     0(a3,d7.l)          ; get new float in d1
  12.         clr.l   d0
  13.         move.l  d5,a2               ; get mstack
  14.         move.l  8(a2),d0            ; get float value
  15.         lea     2(a3,d0.l),a0       ; get addr of arg's data
  16.         lea     2(a3,d1.l),a1       ; get addr of new float's data
  17.         move.l  (a0)+,(a1)+
  18.         move.l  (a0)+,(a1)+
  19.         move.w  (a0)+,(a1)+
  20.         move.l  d1,-(a7)            ; push the new float
  21. ;CODE
  22.  
  23. :CODE @fp1
  24.         move.l  YERK[(fltNew)],d7  
  25.         jsr     0(a3,d7.l)          ; get new float in d1
  26.         clr.l   d0
  27.         move.l  d5,a2               ; get mstack
  28.         move.l  12(a2),d0            ; get float value
  29.         lea     2(a3,d0.l),a0       ; get addr of arg's data
  30.         lea     2(a3,d1.l),a1       ; get addr of new float's data
  31.         move.l  (a0)+,(a1)+
  32.         move.l  (a0)+,(a1)+
  33.         move.w  (a0)+,(a1)+
  34.         move.l  d1,-(a7)            ; push the new float
  35. ;CODE
  36.  
  37. \ fetch the floating point arg whose offset is at the IP
  38. :CODE @fp2
  39.         move.l  YERK[(fltNew)],d7  
  40.         jsr     0(a3,d7.l)          ; get new float in d1
  41.         clr.l   d0
  42.         move.l  d5,a2               ; get mstack
  43.         move.l  16(a2),d0            ; get float value
  44.         lea     2(a3,d0.l),a0       ; get addr of arg's data
  45.         lea     2(a3,d1.l),a1       ; get addr of new float's data
  46.         move.l  (a0)+,(a1)+
  47.         move.l  (a0)+,(a1)+
  48.         move.w  (a0)+,(a1)+
  49.         move.l  d1,-(a7)            ; push the new float
  50. ;CODE
  51.  
  52. \ fetch the floating point arg whose offset is at the IP
  53. :CODE @fp3
  54.         move.l  YERK[(fltNew)],d7  
  55.         jsr     0(a3,d7.l)          ; get new float in d1
  56.         clr.l   d0
  57.         move.l  d5,a2               ; get mstack
  58.         move.l  20(a2),d0            ; get float value
  59.         lea     2(a3,d0.l),a0       ; get addr of arg's data
  60.         lea     2(a3,d1.l),a1       ; get addr of new float's data
  61.         move.l  (a0)+,(a1)+
  62.         move.l  (a0)+,(a1)+
  63.         move.w  (a0)+,(a1)+
  64.         move.l  d1,-(a7)            ; push the new float
  65. ;CODE
  66.  
  67. \ fetch the floating point arg whose offset is at the IP
  68. :CODE @fp4
  69.         move.l  YERK[(fltNew)],d7  
  70.         jsr     0(a3,d7.l)          ; get new float in d1
  71.         clr.l   d0
  72.         move.l  d5,a2               ; get mstack
  73.         move.l  24(a2),d0            ; get float value
  74.         lea     2(a3,d0.l),a0       ; get addr of arg's data
  75.         lea     2(a3,d1.l),a1       ; get addr of new float's data
  76.         move.l  (a0)+,(a1)+
  77.         move.l  (a0)+,(a1)+
  78.         move.w  (a0)+,(a1)+
  79.         move.l  d1,-(a7)            ; push the new float
  80. ;CODE
  81.  
  82. \ fetch the floating point arg whose offset is at the IP
  83. :CODE @fp5
  84.         move.l  YERK[(fltNew)],d7  
  85.         jsr     0(a3,d7.l)          ; get new float in d1
  86.         clr.l   d0
  87.         move.l  d5,a2               ; get mstack
  88.         move.l  28(a2),d0            ; get float value
  89.         lea     2(a3,d0.l),a0       ; get addr of arg's data
  90.         lea     2(a3,d1.l),a1       ; get addr of new float's data
  91.         move.l  (a0)+,(a1)+
  92.         move.l  (a0)+,(a1)+
  93.         move.w  (a0)+,(a1)+
  94.         move.l  d1,-(a7)            ; push the new float
  95. ;CODE
  96.  
  97. \ store a new float in the arg whose offset is at the IP
  98. :CODE   !fp(ip)
  99.         move.w  (a4)+,d2            ; pickup arg offset
  100.         move.l  d5,a2               ; get mstack
  101.         move.l  0(a2,d2.w),d0       ; get old float value
  102.         beq     noDisp              ; if 0, don't dispose
  103.         move.l  YERK[(fltDisp)],d7
  104.         jsr     0(a3,d7.l)          ; dispose of old float
  105. noDisp  move.l  (a7)+,0(a2,d2.w)    ; store new float in mstack cell
  106. ;CODE
  107.  
  108. \ add a float to the arg whose offset is at the IP
  109. :CODE   +fp(ip)
  110.         move.w  (a4)+,d2            ; pickup arg offset
  111.         move.l  d5,a2               ; get mstack
  112.         move.l  0(a2,d2.w),d1       ; get contents of arg in d1 = rcvr
  113.         beq     notInit             ; if 0, don't proceed
  114.         move.l  (a7)+,d0            ; get parm
  115.         pea     2(a3,d0.l)          ; push parm absolute
  116.         pea     2(a3,d1.l)          ; push rcvr absolute
  117.         move.l  YERK[(fltDisp)],d7  ; get subr addr in d7
  118.         jsr     0(a3,d7.l)          ; go dispose of parm in d0
  119.         clr.w   -(A7)               ; code for FADD
  120.         call pack4
  121.         move.l  (a4)+,d6            ; do next
  122.         move.l  0(a3,d6.l),d7
  123.         jmp     0(a3,d7.l) 
  124. notInit  move.l #3,d1                
  125.         move.l  YERK[fpErr],d7
  126.         move.l  YERK[execWord],d6
  127.         jmp     0(a3,d6.l)                
  128. ;CODE
  129.  
  130. \ deallocate the floats held in named input args.  This cfa
  131. \ is compiled before (;m) in words that have float args.  A 16-bit word at
  132. \ the IP holds a bitmask indicating which args are float.
  133. :CODE  killFargs
  134.         move.w  (a4)+,d2        ; get bitmask
  135.         move.l  d5,a2           ; get mstack
  136.         move.l  YERK[(fltDisp)],d7
  137.         addq.l  #8,a2           ; point to 0th arg
  138. kf1     asr.w   #1,d2           ; shift low bit into carry
  139.         bcc     noDisp          ; if carry clear, not a float
  140.         beq     kfLast          ; if 0, no more to shift
  141.         move.l  (a2),d0         ; get the float
  142.         beq     noDisp          ; skip uninitialized floats
  143.         jsr     0(a3,d7.l)      ; kill it
  144. noDisp  addq.l  #4,a2           ; next cell
  145.         bra     kf1             ; loop 
  146. kfLast  move.l  (a2),d0         ; get the float
  147.         jsr     0(a3,d7.l)      ; kill it
  148. ;CODE  
  149.         
  150. 'c @fp0  fpicks !
  151. 'c @fp1  fpicks 4+ !
  152. 'c @fp2  fpicks 8+ !
  153. 'c @fp3  fpicks 12 + !
  154. 'c @fp4  fpicks 16 + !
  155. 'c @fp5  fpicks 20 + !
  156.  
  157. 'c !fp(ip)  -> farg!
  158. 'c +fp(ip)  -> farg++
  159. 'c killfargs -> fkill
  160.  
  161. \ ;M checks if the latest method has named float args, and if so,
  162. \ compiles the float disposal routine before the end of the method.
  163. : ;M   ?csp [compile] mexit ;  immediate
  164.